﻿#VisualFreeBasic_Form#  Version=5.8.1
Locked=0

[Form]
Name=runForm
ClassStyle=CS_VREDRAW,CS_HREDRAW,CS_DBLCLKS
ClassName=
WinStyle=WS_VISIBLE,WS_EX_CONTROLPARENT,WS_EX_LEFT,WS_EX_LTRREADING,WS_EX_RIGHTSCROLLBAR,WS_CLIPSIBLINGS,WS_CLIPCHILDREN,WS_CHILD
Style=0 - 无边框
Icon=
Caption=
StartPosition=1 - 屏幕中心
WindowState=0 - 正常
Enabled=True
Repeat=False
Left=0
Top=0
Width=500
Height=310
TopMost=False
Child=True
MdiChild=False
TitleBar=False
SizeBox=False
SysMenu=False
MaximizeBox=False
MinimizeBox=False
Help=False
Hscroll=False
Vscroll=False
MinWidth=0
MinHeight=0
MaxWidth=0
MaxHeight=0
NoActivate=False
MousePass=False
TransPer=0
TransColor=SYS,25
Shadow=0 - 无阴影
BackColor=SYS,15
MousePointer=0 - 默认
Tag=
Tab=True
ToolTip=
ToolTipBalloon=False
AcceptFiles=False

[Custom]
Name=Scintilla
Index=-1
ClassName=Scintilla
BStyle=0 - 无边框
Caption=
Enabled=True
Visible=True
ForeColor=SYS,8
BackColor=SYS,25
Font=微软雅黑,9
Left=82
Top=63
Width=202
Height=68
Layout=0 - 不锚定
MousePointer=0 - 默认
Tag=
Tab=True
ToolTip=
ToolTipBalloon=False
AcceptFiles=False

[PopupMenu]
Name=PopupMenu1
Index=-1
Menu=撤销PopupMenu1_撤销0-10重做PopupMenu1_重做0-10-PopupMenu1_10-10剪切PopupMenu1_剪切0-10复制PopupMenu1_复制0-10粘贴PopupMenu1_粘贴0-10删除PopupMenu1_删除0-10-PopupMenu1_20-10全选PopupMenu1_全选0-10清空PopupMenu1_清空0-10
Left=83
Top=184
Tag=

[Timer]
Name=Timer1
Index=-1
Interval=300
Enabled=True
Left=207
Top=167
Tag=


[AllCode]
Dim Shared run_pSci As Any Ptr 
Dim Shared 缓存(999) As String ,缓存处理 As Long ,缓存储存 As Long '为调试输出缓存处理，用于大量数据
Sub runForm_WM_Create(hWndForm As hWnd, UserData As Integer)  '完成创建窗口及所有的控件后，此时窗口还未显示。注：自定义消息里 WM_Create 此时还未创建控件和初始赋值。
   If SciMsg = 0 Then
      SciMsg = Cast(Scintilla_DirectFunction, SendMessage(Scintilla.hWnd, SCI_GETDIRECTFUNCTION, 0, 0))
   End If
   run_pSci = Cast(Any Ptr, SendMessage(Scintilla.hWnd, SCI_GETDIRECTPOINTER, 0, 0))
   sci_Properties run_pSci
   
   Dim vfbAPP As APP_TYPE Ptr  = GetExeAPP() 
   Dim ss As String = GetFileStr(vfbAPP->Path  & "Settings\vbs.txt" )
   If Len(ss) = 0 Then
      ss = StrToUtf8(vfb_LangString("这里按回车就执行当前行VBS代码，无需 打 ？ 或 Print 执行结果就会在下一行显示。") & vbCrLf & _
      vfb_LangString("这里执行的是VBS代码，不是FB代码，都是Basic语系，基础语句和语法都是相同的。") ) & vbCrLf & vbCrLf  
   End If 
   SciMsg(run_pSci, SCI_SETTEXT, 0, Cast(lParam, StrPtr(ss)))
   
End Sub

'改变大小 [事件]   hWndForm=窗体句柄  fwSizeType=请求要调整大小的类型  nWidth=客户区新的宽度  nHeight=客户区新的高度
Sub runForm_WM_Size(hWndForm As hWnd, fwSizeType As Long, nWidth As Long, nHeight As Long)  '窗口已经改变了大小
   Scintilla.Move 0, 0, nWidth, nHeight
   
End Sub



'自定义 [事件]   ControlIndex=控件数组索引  hWndForm=窗体句柄  hWndControl=控件句柄  wMsg=消息类型  wParam=第一个消息参数  lParam=第二个消息参数
Function runForm_Text1_Custom(hWndForm As hWnd, hWndControl As hWnd, wMsg As UInteger, wParam As wParam, lParam As lParam) As LResult  '自定义消息（全部消息），在其它事件后处理，返回非0，终止系统处理此消息。
'   Select Case wMsg
'      Case WM_KeyDown
'         If wParam = 13 Then
'            PostMessage(hWndControl, WM_USER + 500, Text1.SelStart, 0)
'            Return True
'         End If
'      Case WM_KeyUp
'         
'      Case WM_USER + 500
'         Dim aa As CWStr = Text1.Text
'         Dim LL As Long = wParam + 1
'         Dim As CWStr b1,b2,b3,b4
'         Dim ff As Long = InStrRev(Left(aa.WStr, LL), WChr(13, 10), -1)
'         If ff = 0 Then
'            b1 = ""
'            b2 = aa
'         Else
'            b1 = Left(aa.WStr, ff + 1)
'            b2 = Mid(aa.WStr, ff + 2)
'         End If
'         ff = InStr(b2.WStr, WChr(13, 10))
'         If ff = 0 Then
'            b3 = ""
'         Else
'            b3 = Mid(b2.WStr, ff)
'            b2 = Left(b2.WStr, ff -1)
'         End If
'         
'         Dim vbs As vbVariant = CreateObject("MSScriptControl.ScriptControl")
'         vbs.Put("Language", "s", "VBScript")
'         Dim ss As String = b2
'         ff = InStr(ss, vbCrLf)
'         If ff > 0 Then ss = Left(ss, ff -1)
'         Dim bb4 As String
'         bb4 = vbs.Get("Eval", "s", ss) '利用COM对象获取VBS计算结果
'         b4 = bb4
'         b1 &= b2 & WChr(13, 10) & b4
'         ff = Len(b1.WStr)
'         If Right(b3, 4) <> Chr(13, 10, 13, 10) Then b3 &= Chr(13, 10, 13, 10)
'         Text1.Text = b1 & b3
'         Text1.SetSel ff, ff
'         Text1.SetFocus
'   End Select
   
   Function = 0
End Function
Sub sci_Properties(pSci As Any Ptr) '给编辑器设置属性
   
   Dim rxRatio    As Single = AfxScaleX(1) 'DPI比率
   Dim ryRatio    As Single = AfxScaleY(1)
   Dim nPixels    As Long ' 行号宽度
   Dim bitsNeeded As Long '需要的位
   Dim tStr       As ZString * 1024
   Dim zz         As String = "Microsoft YaHei"
   SciMsg(pSci ,SCI_STYLESETFONT ,STYLE_DEFAULT ,Cast(lParam ,StrPtr(zz)))
   SciMsg(pSci ,SCI_STYLESETSIZE ,STYLE_DEFAULT ,9)
   '   SciMsg(pSci, SCI_STYLESETCHARACTERSET, STYLE_DEFAULT, GetFontCharSetID(op.EditorFontCharSet))
   Dim ThemesX As Long = ThemeWin.colors(Themes_窗口).nBg
   Dim 背景色 As Long = HSBtoRGB_Gdi(ThemesX)
   Dim 文字色 As Long = 色差绝对HSBtoGDI(ThemesX)
   Dim 色差20 As Long =  色差亮度HSBtoGDI(ThemesX ,20)
   SciMsg(pSci ,SCI_STYLESETFORE ,STYLE_DEFAULT ,  文字色 )
   SciMsg(pSci ,SCI_STYLESETBACK ,STYLE_DEFAULT ,  背景色 )
   SciMsg(pSci, SCI_STYLECLEARALL, 0, 0)  ' 将全局样式复制到所有其他样式
   SciMsg(pSci ,SCI_STYLESETFORE ,STYLE_LINENUMBER ,色差绝对GDItoGDI(色差20))
   SciMsg(pSci ,SCI_STYLESETBACK ,STYLE_LINENUMBER ,色差20)
   SciMsg(pSci, SCI_SETSELFORE, CTRUE, 背景色)
   SciMsg(pSci, SCI_SETSELBACK, CTRUE, 文字色)
   SciMsg(pSci ,SCI_SETHOTSPOTACTIVEUNDERLINE ,CTRUE ,0) '允许
   ''  当前行颜色
   SciMsg(pSci ,SCI_SETCARETLINEBACK ,色差亮度HSBtoGDI(ThemesX ,10) ,0)   
   SciMsg(pSci ,SCI_SETCARETLINEVISIBLE ,CTRUE ,0)
      '  始终保持插入符号行可见
   SciMsg(pSci, SCI_SETCARETLINEVISIBLEALWAYS, CTRUE, 0)
   ''
   ''  边距0：行号（默认为宽度0）
   tStr    = "_9999"
   nPixels = SciMsg(pSci ,SCI_TEXTWIDTH ,0 ,Cast(lParam ,@tStr))
   SciMsg(pSci ,SCI_SETMARGINTYPEN ,0 ,SC_MARGIN_NUMBER)
   SciMsg(pSci ,SCI_SETMARGINWIDTHN ,0 ,nPixels)
   SciMsg(pSci ,SCI_SETMARGINWIDTHN ,1 ,0)
   SciMsg(pSci ,SCI_SETMARGINWIDTHN ,2 ,0)
   ''
   ''  显示缩进参考线
   SciMsg(pSci ,SCI_SETINDENTATIONGUIDES ,False ,0)
   
   SciMsg(pSci ,SCI_SETHSCROLLBAR ,False ,0) '禁用水平滚动
   
   ''  标识要在单词中使用的字符
   'tStr = "~_:\abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
   'SciMsg(pSci ,SCI_SETWORDCHARS ,0 ,Cast(lParam ,@tStr))
   
   ''  Unicode（UTF-8编码）
   SciMsg(pSci ,SCI_SETCODEPAGE ,SC_CP_UTF8 ,0)
   
   '   SciMsg(pSci, SCI_SETEXTRAASCENT, 2, 2) '字符上空位
   '   SciMsg(pSci, SCI_SETEXTRADESCENT, 2, 2) '字符下空位
   
   SciMsg(pSci ,SCI_SETLEXER ,SCLEX_VB ,0)
   SciMsg(pSci ,SCI_USEPOPUP ,False ,0)
   '设置FreeBASIC关键字
   '   If Len(op.FBKeywordsC) Then
   '      SciMsg(pSci, SCI_SETKEYWORDS, 0, Cast(lParam, StrPtr(op.FBKeywordsC)))
   '   End If
   '   If Len(op.APIKeywordsC) Then
   '      SciMsg(pSci, SCI_SETKEYWORDS, 1, Cast(lParam, StrPtr(op.APIKeywordsC)))
   '   End If
   '   If Len(op.LibKeywordsC) Then
   '      SciMsg(pSci, SCI_SETKEYWORDS, 2, Cast(lParam, StrPtr(op.LibKeywordsC)))
   '   End If
   '禁止折叠程序和功能
   tStr = "fold"
   SciMsg(pSci ,SCI_SETPROPERTY ,Cast(wParam ,@tStr) ,Cast(lParam ,@"0"))
   
   
End Sub

Sub runForm_Scintilla_WM_KeyDown(hWndForm As hWnd ,hWndControl As hWnd ,nVirtKey As Long ,lKeyData As Long) '按下某按键，并已发出WM_KEYDOWN、WM_KEYUP消息
   
   If nVirtKey = 13 Then
      Dim nLine As Long   = Code_GetCurrentLineNumberP(run_pSci)
      Dim ss    As String = Code_GetLineP(run_pSci ,nLine)
      If Len(ss)>0 AndAlso Asc(ss,1)<123 AndAlso  Left(ss ,1) <> "["  Then
         Dim vbs As vbVariant = CreateObject("MSScriptControl.ScriptControl")
         vbs.Put("Language" ,"s" ,"VBScript")
         Dim bb4 As String
         bb4 = vbs.Get("Eval" ,"s" ,ss) '利用COM对象获取VBS计算结果
         SciMsg(run_pSci ,SCI_INSERTTEXT , -1 ,Cast(lParam ,StrPtr(bb4)))
         PostMessage(hWndForm ,&H501 ,&H501 ,Len(bb4)) '默认为 PostMessageW
      End If
   End If
End Sub

Function runForm_Custom(hWndForm As hWnd ,wMsg As UInteger ,wParam As wParam ,lParam As lParam) As LResult '自定义消息（全部消息），在其它事件后处理，返回非0，终止系统处理此消息。
   Select Case wMsg
      Case wMsg = &H501
         If wParam = &H501 Then
            Dim nPos As Long = SciMsg(run_pSci ,SCI_GETCURRENTPOS ,0 ,0) + lParam
            SciMsg(run_pSci ,SCI_GOTOPOS ,nPos ,0)
         End If
      Case WM_COPYDATA
         if wParam = &H502 Then ' 来自软件  调试输出
            Dim aa As COPYDATASTRUCT Ptr = Cast(Any Ptr ,lParam)
            Dim bb As String = "[" & Format(Now ,"hh:mm:ss") & Right(Format(Timer ,"0.00") ,3) & "]" & wStrToUtf8( *CPtr(Wstring Ptr ,aa->lpData))
            Dim i As Long = 缓存储存 + 1
            If i > 999 Then i = 0
            缓存(i) = bb 
            缓存储存 = i

         End If
   End Select
   Function = 0 '根据自己需要修改
End Function

Function runForm_WM_Close(hWndForm As hWnd) As LResult  '即将关闭窗口，返回非0可阻止关闭

   Function = 0 '根据自己需要修改
End Function

Sub runForm_Scintilla_WM_ContextMenu(hWndForm As hWnd, hWndControl As hWnd, xPos As Long, yPos As Long)  '鼠标右键单击
   PopupMenu1.PopupMenu
End Sub

Sub runForm_PopupMenu1_WM_Command(hWndForm As hWnd, wID As ULong)  '点击了菜单项
   Select Case wID
      Case PopupMenu1_撤销 ' 撤销
         SciMsg(run_pSci, SCI_UNDO, 0, 0)
      Case PopupMenu1_重做 ' 重做
         SciMsg(run_pSci, SCI_REDO, 0, 0)
      Case PopupMenu1_剪切 ' 剪切
         SciMsg(run_pSci, SCI_CUT, 0, 0)
      Case PopupMenu1_复制 ' 复制
         SciMsg(run_pSci, SCI_COPY, 0, 0)
      Case PopupMenu1_粘贴 ' 粘贴
         SciMsg(run_pSci, SCI_PASTE, 0, 0)
      Case PopupMenu1_删除 ' 删除
         SciMsg(run_pSci, SCI_DELETERANGE, 0, 0)
      Case PopupMenu1_全选 ' 全选
         SciMsg(run_pSci, SCI_SELECTALL, 0, 0)
      Case PopupMenu1_清空 ' 清空
         SciMsg(run_pSci, SCI_CLEARALL, 0, 0)
   End Select
   
End Sub

Function Code_GetCurrentLineNumberP(pSci As Any Ptr) As Long  '' 获取当前行号
     Dim nPos As Long = SciMsg(pSci, SCI_GETCURRENTPOS, 0, 0)
     Function = SciMsg(pSci, SCI_LINEFROMPOSITION, nPos, 0)
End Function 
Function Code_GetLineP(pSci As Any Ptr, ByVal nLine As Long) As String '获取行文本，原文尾部带 13,10 ，已经消除
   Dim nLen As Long
   Dim buffer As String
   nLen = SciMsg(pSci, SCI_LINELENGTH, nLine, 0)
   If nLen < 1 Then Exit Function
   buffer = Space(nLen)
   SciMsg(pSci, SCI_GETLINE, nLine, Cast(lParam, StrPtr(buffer)))
   Function = RTrim(buffer, Any Chr(13, 10, 0))
End Function
Function Code_GetTextP(pSci As Any Ptr) As String  '文本是 Utf8 格式
   
   Dim nLen As Long
   Dim buffer As String
   nLen = SciMsg(pSci, SCI_GETLENGTH, 0, 0)
   If nLen < 1 Then Exit Function
   buffer = String(nLen + 1, 0)
   SciMsg(pSci, SCI_GETTEXT, nLen + 1, Cast(lParam, StrPtr(buffer)))
   Function = Trim(buffer, Chr(0))
   
   
End Function

Sub runForm_Timer1_WM_Timer(hWndForm As hWnd ,wTimerID As Long) '定时器
   Dim i  As Long = 缓存处理
   Dim ti As Long = 缓存储存
   If i <> ti Then
      Dim u As Long = SciMsg(run_pSci ,SCI_GETLINECOUNT ,0 ,0) '获取总行数
      If u > 9000 Then
         '太多了，删除最前面 1000行
         dim endPos as Long = SciMsg(run_pSci ,SCI_GETLINEENDPOSITION ,999 ,0)
         SciMsg(run_pSci ,SCI_SETCURRENTPOS ,0 ,0)  '选择位置
         SciMsg(run_pSci ,SCI_SETANCHOR ,endPos ,0) '结束选择
         Dim strText As String = "...."
         SciMsg(run_pSci ,SCI_REPLACESEL ,Len(strText) ,Cast(lParam ,StrPtr(strText)))
      End If
      Dim nPos As Long = SciMsg(run_pSci ,SCI_GETLENGTH ,0 ,0)
      SciMsg(run_pSci ,SCI_SETCURRENTPOS ,nPos ,0)
      Dim bb As String
      Do
         i += 1
         If i > 999      Then i  = 0
         if Len(缓存(i)) Then bb &= 缓存(i) & vbCrLf
         If i = ti       Then Exit Do
      Loop
      缓存处理 = ti
      If Len(bb) Then
         SciMsg(run_pSci ,SCI_ADDTEXT ,Len(bb) ,Cast(lParam ,StrPtr(bb)))
         SciMsg(run_pSci ,SCI_GOTOPOS ,nPos + Len(bb)-2 ,0)
      End If
   End If
End Sub







